home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Internet Tools 1993 July / Internet Tools.iso / RockRidge / mail / pine / imap-3.0 / MM-D / smtp < prev    next >
Encoding:
Text File  |  1988-12-24  |  38.1 KB  |  719 lines
  1. (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
  2. (FILECREATED " 7-Jun-88 13:01:31" {SAFE}</B/MRC>SMTP.;69 38012  
  3.  
  4.       previous date%: "26-May-88 09:33:45" |{MCS:MCS:STANFORD}<LANE>MM>SMTP.;9|
  5. )
  6.  
  7.  
  8. (PRETTYCOMPRINT SMTPCOMS)
  9.  
  10. (RPAQQ SMTPCOMS 
  11.        (                                       (* ; 
  12.                             "Simple Mail Transport Protocol --- Mark Crispin")
  13.                                                (* ; 
  14.           "Mail Transfer Protocol routines --- interface between SMTP and MM")
  15.         (FNS MTP.ENVELOPE MTP.DISPLAY.ENVELOPE MTP.ENVELOPE.TOLIST 
  16.              MTP.ENVELOPE.SUBJECT MTP.MAIL MTP.TTYLINE)
  17.                                                (* ; 
  18.                              "Simple Mail Transfer Protocol support routines")
  19.         (FNS SMTP.MAIL SMTP.OPEN SMTP.OPEN.TCP SMTP.LOGOUT SMTP.REPLY SMTP.SEND
  20.              SMTP.START SMTP.RCPT SMTP.DATA SMTP.MAILBOX SMTP.LOCK SMTP.UNLOCK)
  21.                                                (* ; "SMTP contact ports")
  22.         (CONSTANTS (SMTP.PORT.TCP 25))
  23.                                                (* ; "SMTP codes")
  24.         (CONSTANTS (SMTP.GREET 220)
  25.                (SMTP.OK 250)
  26.                (SMTP.READY 354)
  27.                (SMTP.SOFTFATAL 421))
  28.                                                (* ; 
  29.                                              "Single line string readtable")
  30.         [INITVARS (SMTP.RDTBL (COPYREADTABLE 'ORIG]
  31.         (P (for I from 0 to 127 do (SETSYNTAX I 'OTHER SMTP.RDTBL))
  32.            (SETSYNTAX (CHARCODE CR)
  33.                   'BREAKCHAR SMTP.RDTBL))
  34.                                                (* ; "Commonly used strings")
  35.         [INITVARS (MTP.CRLF (CONCAT (CHARACTER (CHARCODE CR))
  36.                                    (CHARACTER (CHARCODE LF]
  37.                                                (* ; "RFC822 support routines")
  38.         (FNS RFC822.MESSAGE RFC822.HEADER RFC822.HEADER.LINE RFC822.DATE 
  39.              RFC822.MESSAGE-ID RFC822.MAILBOX)
  40.                                                (* ; "RFC822 parsing routines")
  41.         (FNS RFC822.PARSE.MAILBOX RFC822.PARSE.PHRASE RFC822.PARSE.ROUTEADDR 
  42.              RFC822.PARSE.ADDRSPEC RFC822.PARSE.WORD RFC822.TRIM.WHITESPACE)
  43.         (INITVARS (RFC822.DELIMITERS (CHARCODE (NULL ^A ^B ^C ^D ^E ^F ^G ^H ^I
  44.                                                      ^J ^K ^L ^M ^N ^O ^P ^Q ^R
  45.                                                      ^S ^T ^U ^V ^W ^X ^Y ^Z 
  46.                                                      ^%[ ^\ ^%] ^^ ^_ SPACE %(
  47.                                                      %) < > @ %, ; %: %" %[ %]
  48.                                                      DEL)))
  49.                (RFC822.HOST.DELIMITERS (CHARCODE (NULL ^A ^B ^C ^D ^E ^F ^G ^H
  50.                                                        ^I ^J ^K ^L ^M ^N ^O ^P
  51.                                                        ^Q ^R ^S ^T ^U ^V ^W ^X
  52.                                                        ^Y ^Z ^%[ ^\ ^%] ^^ ^_ 
  53.                                                        SPACE %( %) < > @ %, ; 
  54.                                                        %: %" DEL)))
  55.                (RFC822.LWSPCHARNEGTABLE (MAKEBITTABLE (LIST (CHARCODE SPACE)
  56.                                                             (CHARCODE TAB))
  57.                                                T)))
  58.                                                (* ; 
  59.                                              "User-settable parameters")
  60.         (INITVARS (SMTP.PROTOCOL 'TCP)
  61.                (SMTP.DEBUG NIL)
  62.                (SMTP.GAG T)
  63.                (SMTP.LOCKDEBUG NIL)
  64.                (SMTP.EOF (CONCAT MTP.CRLF ".")))
  65.                                                (* ; "Declare all globals")
  66.         (GLOBALVARS SMTP.PORT.TCP SMTP.RDTBL MTP.CRLF RFC822.DELIMITERS 
  67.                RFC822.HOST.DELIMITERS RFC822.LWSPCHARNEGTABLE SMTP.PROTOCOL 
  68.                SMTP.DEBUG SMTP.GAG SMTP.LOCKDEBUG SMTP.EOF)
  69.         (GLOBALVARS PROMPTWINDOW \IP.DEFAULT.CONFIGURATION 
  70.                INTERNET.LOCAL.DOMAIN)
  71.                                                (* ; "Internet domain service")
  72.         (FILES TCPDOMAIN)))
  73.  
  74.  
  75.  
  76. (* ; "Simple Mail Transport Protocol --- Mark Crispin")
  77.  
  78.  
  79.  
  80.  
  81. (* ; "Mail Transfer Protocol routines --- interface between SMTP and MM")
  82.  
  83. (DEFINEQ
  84.  
  85. (MTP.ENVELOPE
  86.   [LAMBDA (WINDOW MESSAGE)                               (* ; "Edited 19-Feb-88 12:30 by MRC")
  87.                                                              (* ; 
  88.                                                "Prompts for and parses RFC822 envelope information")
  89.     (with MM.MESSAGE MESSAGE (while (NOT To) do (MTP.ENVELOPE.TOLIST WINDOW MESSAGE
  90.                                                                    'To))
  91.            (MTP.ENVELOPE.TOLIST WINDOW MESSAGE 'cc))
  92.     (MTP.ENVELOPE.SUBJECT WINDOW MESSAGE])
  93.  
  94. (MTP.DISPLAY.ENVELOPE
  95.   [LAMBDA (MESSAGE)                                      (* ; "Edited 17-Aug-87 18:55 by MRC")
  96.                                                              (* ; 
  97.                                               "Display the envelope for the message being composed")
  98.     (CONCAT (RFC822.HEADER.LINE 'From (fetch (MM.MESSAGE From) of MESSAGE)
  99.                    T)
  100.            (LET (NEWSTRING)
  101.                 (CONCATLIST (for FIELD in '(Sender Reply-To Subject To cc bcc)
  102.                                collect (if (SETQ NEWSTRING
  103.                                                     (RFC822.HEADER.LINE
  104.                                                      FIELD
  105.                                                      (RECORDACCESS FIELD MESSAGE
  106.                                                             (CONSTANT (RECLOOK 'MM.MESSAGE))
  107.                                                             'FETCH)
  108.                                                      T))
  109.                                                then (CONCAT (CHARACTER (CHARCODE CR))
  110.                                                                NEWSTRING)
  111.                                              else ""])
  112.  
  113. (MTP.ENVELOPE.TOLIST
  114.   [LAMBDA (WINDOW MESSAGE LISTNAME)                      (* ; "Edited 17-Aug-87 18:56 by MRC")
  115.                                                              (* ; 
  116.                                                   "Prompts for and parses a generic RFC822 to-list")
  117.     (LET (LINE RECIPIENT (MOREFLG T))
  118.          (while MOREFLG
  119.             do (SETQ LINE (RFC822.TRIM.WHITESPACE (MTP.TTYLINE (CONCAT LISTNAME ": ")
  120.                                                                  WINDOW)))
  121.                   (SETQ MOREFLG NIL)
  122.                   (while LINE
  123.                      do (if (SETQ RECIPIENT (RFC822.PARSE.MAILBOX LINE))
  124.                                 then (RECORDACCESS LISTNAME MESSAGE (CONSTANT (RECLOOK
  125.                                                                                    'MM.MESSAGE))
  126.                                                 'REPLACE
  127.                                                 (APPEND (RECORDACCESS LISTNAME MESSAGE
  128.                                                                (CONSTANT (RECLOOK 'MM.MESSAGE))
  129.                                                                'FETCH)
  130.                                                        (LIST RECIPIENT)))
  131.                                       (if (SETQ LINE (RFC822.TRIM.WHITESPACE
  132.                                                           (fetch (MM.ADDRESS Extra) of 
  133.                                                                                             RECIPIENT
  134.                                                                  )))
  135.                                           then (if (EQ (NTHCHARCODE LINE 1)
  136.                                                                (CHARCODE %,))
  137.                                                        then (SETQ LINE (RFC822.TRIM.WHITESPACE
  138.                                                                             (SUBSTRING LINE 2)))
  139.                                                      else (printout WINDOW 
  140.                                                                      "Junk at end of mailbox: " LINE
  141.                                                                      T)
  142.                                                            (SETQ LINE NIL))
  143.                                                 (SETQ MOREFLG (NOT LINE)))
  144.                               else (printout WINDOW "Bad mailbox: " LINE T)
  145.                                     (SETQ LINE NIL)
  146.                                     (SETQ MOREFLG T])
  147.  
  148. (MTP.ENVELOPE.SUBJECT
  149.   [LAMBDA (WINDOW MESSAGE)                               (* ; "Edited 19-Feb-88 12:31 by MRC")
  150.                                                              (* ; 
  151.                                                 "Prompts for and sets up a Subject in the envelope")
  152.     (replace (MM.MESSAGE Subject) of MESSAGE with (MTP.TTYLINE "Subject: " WINDOW])
  153.  
  154. (MTP.MAIL
  155.   [LAMBDA (WINDOW MESSAGE HOST)                          (* ; "Edited 29-Feb-88 16:23 by MRC")
  156.                                                              (* ; "Queue message to service host")
  157.     (SMTP.MAIL MESSAGE HOST])
  158.  
  159. (MTP.TTYLINE
  160.   [LAMBDA (PROMPT WINDOW)                                (* ; "Edited 24-Feb-88 17:14 by MRC")
  161.                                                              (* ; 
  162.                                                            "Prompt for and get a line from the TTY")
  163.     (RESETFORM (TTYDISPLAYSTREAM WINDOW)
  164.            (TTY.PROCESS (THIS.PROCESS))
  165.            (TTYIN PROMPT NIL NIL '(STRING NORAISE])
  166. )
  167.  
  168.  
  169.  
  170. (* ; "Simple Mail Transfer Protocol support routines")
  171.  
  172. (DEFINEQ
  173.  
  174. (SMTP.MAIL
  175.   [LAMBDA (MESSAGE HOST)                                 (* ; "Edited 29-Feb-88 15:49 by MRC")
  176.                                                              (* ; 
  177.                                                            "Send message to the specified server")
  178.     (PROG ((STREAM (SMTP.OPEN HOST MESSAGE))
  179.            (WINFLG T))
  180.           (if STREAM
  181.               then
  182.               (if (AND (SMTP.START STREAM 'MAIL MESSAGE)
  183.                            (with MM.MESSAGE MESSAGE
  184.                                   (for FIELD in (LIST To cc bcc)
  185.                                      do [if (AND FIELD WINFLG)
  186.                                                 then (for ITEM in FIELD
  187.                                                             do (SETQ WINFLG (SMTP.RCPT STREAM
  188.                                                                                        ITEM]
  189.                                      finally (RETURN WINFLG)))
  190.                            (SMTP.DATA STREAM MESSAGE)
  191.                            (SMTP.LOGOUT STREAM))
  192.                   then (RETURN 'OK)
  193.                 else (SMTP.LOGOUT STREAM])
  194.  
  195. (SMTP.OPEN
  196.   [LAMBDA (HOST MESSAGE)                                 (* ; "Edited 29-Feb-88 16:38 by MRC")
  197.                                                              (* ; 
  198.                       "Opens an SMTP connection, returns stream if successful else an error string")
  199.     (with MM.MESSAGE MESSAGE (SETQ Error NIL)
  200.            (PROG (STREAM REPLY)
  201.                  (if (AND (SETQ STREAM (SELECTQ SMTP.PROTOCOL
  202.                                                (TCP (SMTP.OPEN.TCP HOST))
  203.                                                (ERROR "Unknown SMTP protocol" SMTP.PROTOCOL)))
  204.                               (SETQ REPLY (SMTP.REPLY STREAM))
  205.                               (EQ SMTP.GREET (SUBATOM REPLY 1 3))
  206.                               [SETQ REPLY (SMTP.SEND STREAM 'HELO (LIST " " (GETSTREAMPROP
  207.                                                                                  STREAM
  208.                                                                                  'SMTPLOCALHOST]
  209.                               (EQ SMTP.OK (SUBATOM REPLY 1 3)))
  210.                      then (SMTP.UNLOCK STREAM T)
  211.                            (RETURN STREAM)
  212.                    else (SETQ Error (OR REPLY (CONCAT SMTP.SOFTFATAL " Can't connect to host")))
  213.                          (if STREAM
  214.                              then (CLOSEF STREAM])
  215.  
  216. (SMTP.OPEN.TCP
  217.   [LAMBDA (HOST)                                         (* ; "Edited 25-Mar-88 09:32 by cdl")
  218.                                                              (* ; 
  219.                                                            "Open SMTP connection using TCP/IP")
  220.     (PROG ((HOSTADDR (DOMAIN.HOSTP HOST))
  221.            STREAM)
  222.           (DECLARE (GLOBALVARS INTERNET.LOCAL.DOMAIN \IP.DEFAULT.CONFIGURATION))
  223.           (if HOSTADDR
  224.               then (if (SETQ STREAM (TCP.OPEN HOSTADDR SMTP.PORT.TCP NIL 'ACTIVE 'INPUT T))
  225.                            then (PUTSTREAMPROP STREAM 'OUTSTREAM (TCP.OTHER.STREAM STREAM))
  226.                                  (PUTSTREAMPROP STREAM 'SMTPHOST HOST)
  227.                                  (PUTSTREAMPROP STREAM 'SMTPLOCALHOST (CONCAT (fetch (IPINIT
  228.                                                                                           HOSTNAME)
  229.                                                                                  of 
  230.                                                                             \IP.DEFAULT.CONFIGURATION
  231.                                                                                      )
  232.                                                                              "." 
  233.                                                                              INTERNET.LOCAL.DOMAIN))
  234.                                  (PUTSTREAMPROP STREAM 'SMTPFOREIGNHOST (DOMAIN.LOOKUP.NAME HOSTADDR)
  235.                                         )
  236.                                  (RETURN STREAM))
  237.             else (printout PROMPTWINDOW T "No such host as " HOST])
  238.  
  239. (SMTP.LOGOUT
  240.   [LAMBDA (STREAM)                                       (* ; "Edited 17-Aug-87 18:58 by MRC")
  241.                                                              (* ; "Log out an SMTP connection")
  242.     (SMTP.SEND STREAM 'QUIT)
  243.     (CLOSEF? STREAM)
  244.     'OK])
  245.  
  246. (SMTP.REPLY
  247.   [LAMBDA (STREAM)                                       (* ; "Edited 29-Mar-88 10:30 by cdl")
  248.                                                              (* ; 
  249.                                                            "Reads a reply string from the server")
  250.     (if (AND (OPENP STREAM)
  251.                  (NOT (EOFP STREAM)))
  252.         then (LET ((REPLY (CONSTANT null))
  253.                        REPLYLINE)
  254.                       [while (EQ (NTHCHARCODE (SETQ REPLYLINE (RSTRING STREAM SMTP.RDTBL))
  255.                                             4)
  256.                                      (CHARCODE -)) do (SETQ REPLY (CONCAT REPLY REPLYLINE
  257.                                                                                  (CHARACTER
  258.                                                                                   (BIN STREAM))
  259.                                                                                  (CHARACTER
  260.                                                                                   (BIN STREAM]
  261.                       (SETQ REPLY (CONCAT REPLY REPLYLINE))
  262.                       (if SMTP.DEBUG
  263.                           then (printout PROMPTWINDOW T REPLY)
  264.                         elseif (NOT SMTP.GAG)
  265.                           then (printout PROMPTWINDOW '!))
  266.                                                              (* ; "Slurp TCP/IP newline")
  267.                       (to (CONSTANT (NCHARS MTP.CRLF)) do (BIN STREAM))
  268.                       REPLY)
  269.       else (CONCAT SMTP.SOFTFATAL " SMTP connection went away!"])
  270.  
  271. (SMTP.SEND
  272.   [LAMBDA (STREAM COMMAND ARGS NOUNLOCKFLG NOLOCKFLG)    (* ; "Edited 25-Mar-88 08:32 by cdl")
  273.                                                              (* ; 
  274.                                                            "Sends an SMTP command to the server")
  275.     (if (OR NOLOCKFLG (SMTP.LOCK STREAM))
  276.         then (if (AND (OPENP STREAM)
  277.                               (NOT (EOFP STREAM)))
  278.                      then [LET [(OSTREAM (GETSTREAMPROP STREAM 'OUTSTREAM]
  279.                                                              (* ; 
  280.                                                            "Note: PRIN3 is here for a reason")
  281.                                    (PRIN3 COMMAND OSTREAM)
  282.                                    (if SMTP.DEBUG
  283.                                        then (printout PROMPTWINDOW T COMMAND)
  284.                                      elseif (NOT SMTP.GAG)
  285.                                        then (printout PROMPTWINDOW '+))
  286.                                    [if ARGS
  287.                                        then (RESETFORM (RADIX 10)
  288.                                                        (for ARG inside ARGS
  289.                                                           do (PRIN3 ARG OSTREAM)
  290.                                                                 (if SMTP.DEBUG
  291.                                                                     then (printout PROMPTWINDOW 
  292.                                                                                     ARG]
  293.                                                              (* ; "Note: must use MTP.CRLF here")
  294.                                    (PRIN3 MTP.CRLF OSTREAM)
  295.                                    (FORCEOUTPUT OSTREAM T)
  296.                                    (PROG1 (SMTP.REPLY STREAM)
  297.                                        (if (NOT NOUNLOCKFLG)
  298.                                            then (SMTP.UNLOCK STREAM)))]
  299.                    else (SMTP.UNLOCK STREAM)
  300.                          (CONCAT SMTP.SOFTFATAL "SMTP connection went away!"])
  301.  
  302. (SMTP.START
  303.   [LAMBDA (STREAM TYPE MESSAGE)                          (* ; "Edited 23-Mar-88 18:08 by cdl")
  304.                                                              (* ; "Initiate a MAIL transaction")
  305.     (SMTP.SEND STREAM (CONCAT TYPE " FROM:<"
  306.                                  [with MM.MESSAGE MESSAGE
  307.                                         (if Return-Path
  308.                                             then (SMTP.MAILBOX Return-Path)
  309.                                           else (LET ((HOST (MM.SERVICEHOST)))
  310.                                                         (CONCAT (CAR (\INTERNAL/GETPASSWORD HOST))
  311.                                                                '@ HOST]
  312.                                  '>])
  313.  
  314. (SMTP.RCPT
  315.   [LAMBDA (STREAM ADDRESS)                               (* ; "Edited 26-Jan-88 16:20 by MRC")
  316.                                                              (* ; 
  317.                                                            "Negotiates a single SMTP RCPT command")
  318.     (PROG [(REPLY (SMTP.SEND STREAM "RCPT TO:<" (LIST (SMTP.MAILBOX ADDRESS)
  319.                                                           ">"]
  320.           (with MM.ADDRESS ADDRESS (if (EQ SMTP.OK (SUBATOM REPLY 1 3))
  321.                                            then (SETQ RcptError NIL)
  322.                                                  (RETURN REPLY)
  323.                                          else (SETQ RcptError REPLY])
  324.  
  325. (SMTP.DATA
  326.   [LAMBDA (STREAM MESSAGE)                               (* ; "Edited 28-Jan-88 17:17 by MRC")
  327.                                                              (* ; "Send mail data, end transaction")
  328.     (PROG ((REPLY (SMTP.SEND STREAM 'DATA NIL T)))
  329.           (if (AND (EQ SMTP.READY (SUBATOM REPLY 1 3))
  330.                        (SETQ REPLY (SMTP.SEND STREAM (RFC822.MESSAGE MESSAGE)
  331.                                           SMTP.EOF NIL T))
  332.                        (EQ SMTP.OK (SUBATOM REPLY 1 3)))
  333.               then (RETURN REPLY)
  334.             else (replace (MM.MESSAGE Error) of MESSAGE with REPLY])
  335.  
  336. (SMTP.MAILBOX
  337.   [LAMBDA (ADDRESS)                                      (* ; "Edited 17-Aug-87 18:59 by MRC")
  338.                                                              (* ; "Output an SMTP format address")
  339.     (with MM.ADDRESS ADDRESS
  340.            (if RouteList
  341.                then (CONCAT [CONCATLIST (for route on RouteList
  342.                                                join (LIST '@ (CAR route)
  343.                                                               (if (CDR route)
  344.                                                                   then '%,
  345.                                                                 else '%:]
  346.                                Mailbox "@" Host)
  347.              else (CONCAT Mailbox "@" Host])
  348.  
  349. (SMTP.LOCK
  350.   [LAMBDA (STREAM)                                       (* ; "Edited 17-Aug-87 18:59 by MRC")
  351.                                                              (* ; "Locks the SMTP stream")
  352.     (PROG NIL
  353.           (if (PUTSTREAMPROP STREAM 'SMTPLOCK T)
  354.               then (printout PROMPTWINDOW T "SMTP operation in progress, please wait")
  355.             else (if SMTP.LOCKDEBUG
  356.                          then (printout PROMPTWINDOW '<))
  357.                   (RETURN T])
  358.  
  359. (SMTP.UNLOCK
  360.   [LAMBDA (STREAM NOERROR)                               (* ; "Edited 17-Aug-87 18:59 by MRC")
  361.                                                              (* ; "Unlocks the SMTP stream")
  362.     (if (OR (PUTSTREAMPROP STREAM 'SMTPLOCK NIL)
  363.                 NOERROR)
  364.         then (if SMTP.LOCKDEBUG
  365.                      then (printout PROMPTWINDOW '>))
  366.       else (ERROR "SMTP unlock when already unlocked"])
  367. )
  368.  
  369.  
  370.  
  371. (* ; "SMTP contact ports")
  372.  
  373. (DECLARE%: EVAL@COMPILE 
  374.  
  375. (RPAQQ SMTP.PORT.TCP 25)
  376.  
  377.  
  378. (CONSTANTS (SMTP.PORT.TCP 25))
  379. )
  380.  
  381.  
  382.  
  383. (* ; "SMTP codes")
  384.  
  385. (DECLARE%: EVAL@COMPILE 
  386.  
  387. (RPAQQ SMTP.GREET 220)
  388.  
  389. (RPAQQ SMTP.OK 250)
  390.  
  391. (RPAQQ SMTP.READY 354)
  392.  
  393. (RPAQQ SMTP.SOFTFATAL 421)
  394.  
  395.  
  396. (CONSTANTS (SMTP.GREET 220)
  397.        (SMTP.OK 250)
  398.        (SMTP.READY 354)
  399.        (SMTP.SOFTFATAL 421))
  400. )
  401.  
  402.  
  403.  
  404. (* ; "Single line string readtable")
  405.  
  406.  
  407. (RPAQ? SMTP.RDTBL (COPYREADTABLE 'ORIG))
  408.  
  409. (for I from 0 to 127 do (SETSYNTAX I 'OTHER SMTP.RDTBL))
  410.  
  411. (SETSYNTAX (CHARCODE CR)
  412.        'BREAKCHAR SMTP.RDTBL)
  413.  
  414.  
  415.  
  416. (* ; "Commonly used strings")
  417.  
  418.  
  419. (RPAQ? MTP.CRLF (CONCAT (CHARACTER (CHARCODE CR))
  420.                            (CHARACTER (CHARCODE LF))))
  421.  
  422.  
  423.  
  424. (* ; "RFC822 support routines")
  425.  
  426. (DEFINEQ
  427.  
  428. (RFC822.MESSAGE
  429.   [LAMBDA (MESSAGE)                                      (* ; "Edited 17-Aug-87 19:00 by MRC")
  430.                                                              (* ; 
  431.                                                          "Returns RFC822 representation of message")
  432.     (with MM.MESSAGE MESSAGE (OR Message-ID (SETQ Message-ID (RFC822.MESSAGE-ID)))
  433.            (CONCAT (RFC822.HEADER MESSAGE)
  434.                   MTP.CRLF Body])
  435.  
  436. (RFC822.HEADER
  437.   [LAMBDA (MESSAGE)                                      (* ; "Edited 11-Jan-88 13:38 by MRC")
  438.                                                              (* ; 
  439.  "Returns an RFC822 header for the given message.  This function written for clarity not for speed")
  440.     (CONCATLIST (for FIELD in '(Date From Sender Reply-To Subject To cc Message-ID 
  441.                                              In-Reply-To)
  442.                    collect (OR (RFC822.HEADER.LINE FIELD (RECORDACCESS
  443.                                                                   FIELD MESSAGE
  444.                                                                   (CONSTANT (RECLOOK 'MM.MESSAGE))
  445.                                                                   'FETCH))
  446.                                    ""])
  447.  
  448. (RFC822.HEADER.LINE
  449.   [LAMBDA (FIELDNAME FIELD NONLFLAG)                     (* ; "Edited 23-Mar-88 08:13 by cdl")
  450.                                                              (* ; 
  451.                 "Outputs an RFC822 header line.  This function written for structure not for speed")
  452.     (LET ((NEWLINE (if NONLFLAG
  453.                        then (CONSTANT null)
  454.                      else MTP.CRLF)))
  455.          (SELECTQ FIELDNAME
  456.              (Date (CONCAT "Date: " (RFC822.DATE FIELD)
  457.                           NEWLINE))
  458.              (Message-ID (CONCAT "Message-ID: <" (RFC822.MESSAGE-ID FIELD)
  459.                                 ">" NEWLINE))
  460.              (if FIELD
  461.                  then (CONCAT FIELDNAME ": "
  462.                                  (if (LISTP FIELD)
  463.                                      then [CONCATLIST
  464.                                                (for ITEM on FIELD
  465.                                                   join (LIST (RFC822.MAILBOX (CAR ITEM))
  466.                                                                  (if (CDR ITEM)
  467.                                                                      then ", "
  468.                                                                    else (CONSTANT null]
  469.                                    else FIELD)
  470.                                  NEWLINE])
  471.  
  472. (RFC822.DATE
  473.   [LAMBDA (DATE)                                         (* ; "Edited 25-Mar-88 09:00 by cdl")
  474.                                                              (* ; "Outputs date in RFC822 format")
  475.     (LET [(DATESTRING (GDATE DATE (DATEFORMAT SPACES TIME.ZONE DAY.OF.WEEK DAY.SHORT]
  476.          (CONCAT (SUBSTRING DATESTRING -4 -2)
  477.                 ", "
  478.                 (SUBSTRING DATESTRING (if (EQ (NTHCHARCODE DATESTRING 1)
  479.                                                   (CHARCODE SPACE))
  480.                                           then 2
  481.                                         else 1)
  482.                        -7])
  483.  
  484. (RFC822.MESSAGE-ID
  485.   [LAMBDA (ID)                                           (* ; "Edited 25-Mar-88 09:32 by cdl")
  486.                                                              (* ; 
  487.                                                            "Return an RFC822 format Message ID")
  488.     (OR ID (LET ((HOST (MM.SERVICEHOST)))
  489.                 (DECLARE (GLOBALVARS \IP.DEFAULT.CONFIGURATION))
  490.                 (CONCAT (IDATE)
  491.                        "."
  492.                        (GENSYM)
  493.                        "."
  494.                        (fetch (IPINIT HOSTNAME) of \IP.DEFAULT.CONFIGURATION)
  495.                        "."
  496.                        (CAR (\INTERNAL/GETPASSWORD HOST))
  497.                        "@" HOST])
  498.  
  499. (RFC822.MAILBOX
  500.   [LAMBDA (ADDRESS)                                      (* ; "Edited 17-Aug-87 19:01 by MRC")
  501.                                                              (* ; "Output an RFC822 format address")
  502.     (with MM.ADDRESS ADDRESS (if PersonalName
  503.                                      then (CONCAT PersonalName " <" (SMTP.MAILBOX ADDRESS)
  504.                                                      ">")
  505.                                    else (SMTP.MAILBOX ADDRESS])
  506. )
  507.  
  508.  
  509.  
  510. (* ; "RFC822 parsing routines")
  511.  
  512. (DEFINEQ
  513.  
  514. (RFC822.PARSE.MAILBOX
  515.   [LAMBDA (STRING)                                       (* ; "Edited 17-Aug-87 19:01 by MRC")
  516.                                                              (* ; "Parse an RFC822 format mailbox")
  517.     (LET ((NAMPTR (RFC822.PARSE.PHRASE STRING))
  518.           ADDRESS)
  519.  
  520.          (* ;; "This is much more complicated than it should be because there are still cretins out there who output addrspecs without an @.  This makes it difficult to tell a phrase from an addrspec!")
  521.  
  522.          (if [AND NAMPTR (SETQ ADDRESS (RFC822.PARSE.ROUTEADDR (RFC822.TRIM.WHITESPACE
  523.                                                                         (SUBSTRING STRING
  524.                                                                                (ADD1 NAMPTR]
  525.              then (replace (MM.ADDRESS PersonalName) of ADDRESS
  526.                          with (SUBSTRING STRING 1 NAMPTR))
  527.                    ADDRESS
  528.            else                                          (* ; 
  529.                                                            "No phrase found, look for addrspec")
  530.                  (RFC822.PARSE.ADDRSPEC STRING])
  531.  
  532. (RFC822.PARSE.PHRASE
  533.   [LAMBDA (STRING)                                       (* ; "Edited 17-Aug-87 19:02 by MRC")
  534.                                                              (* ; "Parse an RFC822 phrase")
  535.     (LET ((CURPOS (RFC822.PARSE.WORD STRING))
  536.           WSP NEXT)
  537.          (if (AND CURPOS (NOT (ZEROP CURPOS)))
  538.              then (SETQ WSP (SUB1 (OR (STRPOSL RFC822.LWSPCHARNEGTABLE (SUBSTRING STRING
  539.                                                                                   (ADD1 CURPOS)))
  540.                                           1)))
  541.                    (if [SETQ NEXT (RFC822.PARSE.PHRASE (SUBSTRING STRING
  542.                                                                       (PLUS CURPOS WSP 1]
  543.                        then (if (ZEROP NEXT)
  544.                                     then CURPOS
  545.                                   else (PLUS CURPOS WSP NEXT)))
  546.            else CURPOS])
  547.  
  548. (RFC822.PARSE.ROUTEADDR
  549.   [LAMBDA (STR)                                          (* ; "Edited 17-Aug-87 19:02 by MRC")
  550.                                                              (* ; "Parse an RFC822 route-addr")
  551.     (if (AND STR (GREATERP (NCHARS STR)
  552.                             2)
  553.                  (EQ (NTHCHARCODE STR 1)
  554.                      (CHARCODE <)))
  555.         then (PROG ((ADDRESS (create MM.ADDRESS))
  556.                         (STRING (SUBSTRING STR 2))
  557.                         DELIMITER ENDPTR)
  558.                        (with MM.ADDRESS ADDRESS
  559.                               (while (EQ (NTHCHARCODE STRING 1)
  560.                                              (CHARCODE @))
  561.                                  do (if (NOT (SETQ ENDPTR (RFC822.PARSE.WORD
  562.                                                                    (SETQ STRING (SUBSTRING STRING 2))
  563.                                                                    RFC822.HOST.DELIMITERS)))
  564.                                             then (RETURN))
  565.                                        [SETQ RouteList (APPEND RouteList (LIST (SUBSTRING STRING 1 
  566.                                                                                       ENDPTR]
  567.                                        (if (EQ [SETQ DELIMITER (PROG1 (NTHCHARCODE STRING
  568.                                                                                  (add ENDPTR 1))
  569.                                                                        (SETQ STRING
  570.                                                                         (SUBSTRING STRING
  571.                                                                                (ADD1 ENDPTR))))]
  572.                                                    (CHARCODE %:))
  573.                                            then (RETURN)
  574.                                          elseif (NEQ DELIMITER (CHARCODE %,))
  575.                                            then (SETQ STRING NIL)))
  576.                               (if (AND (RFC822.PARSE.ADDRSPEC STRING ADDRESS)
  577.                                            (EQ (NTHCHARCODE Extra 1)
  578.                                                (CHARCODE >)))
  579.                                   then (SETQ Extra (SUBSTRING Extra 2))
  580.                                         (RETURN ADDRESS])
  581.  
  582. (RFC822.PARSE.ADDRSPEC
  583.   [LAMBDA (STR ADDR)                                     (* ; "Edited 29-Feb-88 15:58 by MRC")
  584.                                                              (* ; "Parse an RFC822 addr-spec")
  585.     (if [AND STR (NOT (ZEROP (NCHARS STR]
  586.         then
  587.         (PROG ((ADDRESS (OR ADDR (create MM.ADDRESS)))
  588.                (STRING (CONCAT STR))
  589.                DELIMITER ENDPTR)
  590.               (with MM.ADDRESS ADDRESS
  591.                      (if (SETQ ENDPTR (RFC822.PARSE.WORD STRING))
  592.                          then (if (AND (NOT (ZEROP ENDPTR))
  593.                                                (SETQ Mailbox (SUBSTRING STRING 1 ENDPTR)))
  594.                                       then (SETQ Host
  595.                                                 (OR [if (EQ (NTHCHARCODE STRING (ADD1 ENDPTR))
  596.                                                                 (CHARCODE @))
  597.                                                         then (AND (SETQ STRING
  598.                                                                        (SUBSTRING STRING
  599.                                                                               (PLUS ENDPTR 2)))
  600.                                                                       (SUBSTRING STRING 1
  601.                                                                              (SETQ ENDPTR
  602.                                                                               (RFC822.PARSE.WORD
  603.                                                                                STRING 
  604.                                                                                RFC822.HOST.DELIMITERS
  605.                                                                                ]
  606.                                                     (MM.SERVICEHOST)))
  607.                                             [if ENDPTR
  608.                                                 then (SETQ Extra (SUBSTRING STRING (ADD1 ENDPTR]
  609.                                             (RETURN ADDRESS))
  610.                        else (SETQ Mailbox STRING)
  611.                              (SETQ Host (MM.SERVICEHOST))
  612.                              (RETURN ADDRESS])
  613.  
  614. (RFC822.PARSE.WORD
  615.   [LAMBDA (STRING DELIMITERS)                            (* ; "Edited 17-Aug-87 19:03 by MRC")
  616.  
  617.     (* ;; "Locate an atom delimiter in an RFC822 format address.  Return character position before the delimiter")
  618.  
  619.     (if STRING
  620.         then (PROG ((CURPOS 1)
  621.                         (MAXPOS (NCHARS STRING))
  622.                         (DELIMS (OR DELIMITERS RFC822.DELIMITERS)))
  623.                                                              (* ; 
  624.              "In the case of a quoted string the end of the quoted string is the position returned")
  625.                        (if (EQ (NTHCHARCODE STRING 1)
  626.                                    (CHARCODE %"))
  627.                            then (while (AND (LEQ (add CURPOS 1)
  628.                                                          MAXPOS)
  629.                                                     (NEQ (NTHCHARCODE STRING CURPOS)
  630.                                                          (CHARCODE %")))
  631.                                        do (if (EQ (NTHCHARCODE STRING CURPOS)
  632.                                                           (CHARCODE \))
  633.                                                   then (add CURPOS 1))
  634.                                        finally (add CURPOS 1))
  635.                          else (while (AND (LEQ CURPOS MAXPOS)
  636.                                                   (NOT (MEMBER (NTHCHARCODE STRING CURPOS)
  637.                                                               DELIMS)))
  638.                                      do (if (EQ (NTHCHARCODE STRING CURPOS)
  639.                                                         (CHARCODE \))
  640.                                                 then (add CURPOS 1))
  641.                                            (add CURPOS 1)))
  642.                        (if (LEQ CURPOS MAXPOS)
  643.                            then (RETURN (SUB1 CURPOS])
  644.  
  645. (RFC822.TRIM.WHITESPACE
  646.   [LAMBDA (STRING)                                       (* ; "Edited 17-Aug-87 19:03 by MRC")
  647.                                                              (* ; "Trim leading whitespace")
  648.     (if STRING
  649.         then (LET ((ENDPOS (STRPOSL RFC822.LWSPCHARNEGTABLE STRING)))
  650.                       (if ENDPOS
  651.                           then (SUBSTRING STRING ENDPOS])
  652. )
  653.  
  654. (RPAQ? RFC822.DELIMITERS 
  655.        (CHARCODE (NULL ^A ^B ^C ^D ^E ^F ^G ^H ^I ^J ^K ^L ^M ^N ^O ^P ^Q ^R ^S
  656.                        ^T ^U ^V ^W ^X ^Y ^Z ^%[ ^\ ^%] ^^ ^_ SPACE %( %) < > @
  657.                        %, ; %: %" %[ %] DEL)))
  658.  
  659. (RPAQ? RFC822.HOST.DELIMITERS 
  660.        (CHARCODE (NULL ^A ^B ^C ^D ^E ^F ^G ^H ^I ^J ^K ^L ^M ^N ^O ^P ^Q ^R ^S
  661.                        ^T ^U ^V ^W ^X ^Y ^Z ^%[ ^\ ^%] ^^ ^_ SPACE %( %) < > @
  662.                        %, ; %: %" DEL)))
  663.  
  664. (RPAQ? RFC822.LWSPCHARNEGTABLE (MAKEBITTABLE (LIST (CHARCODE SPACE)
  665.                                                        (CHARCODE TAB))
  666.                                           T))
  667.  
  668.  
  669.  
  670. (* ; "User-settable parameters")
  671.  
  672.  
  673. (RPAQ? SMTP.PROTOCOL 'TCP)
  674.  
  675. (RPAQ? SMTP.DEBUG NIL)
  676.  
  677. (RPAQ? SMTP.GAG T)
  678.  
  679. (RPAQ? SMTP.LOCKDEBUG NIL)
  680.  
  681. (RPAQ? SMTP.EOF (CONCAT MTP.CRLF "."))
  682.  
  683.  
  684.  
  685. (* ; "Declare all globals")
  686.  
  687. (DECLARE%: DOEVAL@COMPILE DONTCOPY
  688.  
  689. (GLOBALVARS SMTP.PORT.TCP SMTP.RDTBL MTP.CRLF RFC822.DELIMITERS 
  690.        RFC822.HOST.DELIMITERS RFC822.LWSPCHARNEGTABLE SMTP.PROTOCOL SMTP.DEBUG
  691.        SMTP.GAG SMTP.LOCKDEBUG SMTP.EOF)
  692. )
  693. (DECLARE%: DOEVAL@COMPILE DONTCOPY
  694.  
  695. (GLOBALVARS PROMPTWINDOW \IP.DEFAULT.CONFIGURATION INTERNET.LOCAL.DOMAIN)
  696. )
  697.  
  698.  
  699.  
  700. (* ; "Internet domain service")
  701.  
  702.  
  703. (FILESLOAD TCPDOMAIN)
  704. (DECLARE%: DONTCOPY
  705.   (FILEMAP (NIL (4368 9875 (MTP.ENVELOPE 4378 . 4951) (MTP.DISPLAY.ENVELOPE 4953
  706.  . 6205) (MTP.ENVELOPE.TOLIST 6207 . 8782) (MTP.ENVELOPE.SUBJECT 8784 . 9188) (
  707. MTP.MAIL 9190 . 9443) (MTP.TTYLINE 9445 . 9873)) (9939 22168 (SMTP.MAIL 9949 . 
  708. 11173) (SMTP.OPEN 11175 . 12562) (SMTP.OPEN.TCP 12564 . 14220) (SMTP.LOGOUT 
  709. 14222 . 14505) (SMTP.REPLY 14507 . 16119) (SMTP.SEND 16121 . 18264) (SMTP.START 
  710. 18266 . 19031) (SMTP.RCPT 19033 . 19764) (SMTP.DATA 19766 . 20427) (SMTP.MAILBOX
  711.  20429 . 21204) (SMTP.LOCK 21206 . 21712) (SMTP.UNLOCK 21714 . 22166)) (22974 
  712. 27570 (RFC822.MESSAGE 22984 . 23454) (RFC822.HEADER 23456 . 24276) (
  713. RFC822.HEADER.LINE 24278 . 25668) (RFC822.DATE 25670 . 26323) (RFC822.MESSAGE-ID
  714.  26325 . 27056) (RFC822.MAILBOX 27058 . 27568)) (27611 36691 (
  715. RFC822.PARSE.MAILBOX 27621 . 28806) (RFC822.PARSE.PHRASE 28808 . 29763) (
  716. RFC822.PARSE.ROUTEADDR 29765 . 32116) (RFC822.PARSE.ADDRSPEC 32118 . 34320) (
  717. RFC822.PARSE.WORD 34322 . 36268) (RFC822.TRIM.WHITESPACE 36270 . 36689)))))
  718. STOP
  719.